home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Aminet 1 (Walnut Creek)
/
Aminet - June 1993 [Walnut Creek].iso
/
aminet
/
gfx
/
show
/
mugiff1_12.lha
/
MUGiff
/
txt
/
MUGiff.MOD
< prev
next >
Wrap
Text File
|
1993-02-19
|
24KB
|
641 lines
(*-------------------------------------------------------------------------
:Program. MUGiff
:Contents. IFF-Viewer for any ILBM plus 24bit preview and ANIM-player
:Author. Mark Rose [mug]
:Copyright. Freely distributable copyrighted software
:Language. Modula-2
:Translator. M2Amiga 4.1
:Imports. iff.library - Christian A. Weber
:Imports. reqtools.library - Nico François
:Imports. ReqTFileReq - Frank Lömker(optimized&integrated by me)
:History. see file 'History.DEF'
:Usage. MUGiff [<file1> .. <fileN>]
-------------------------------------------------------------------------*)
(*$ NilChk := FALSE ReturnChk := FALSE CaseChk := FALSE *)
(*$ Volatile := FALSE StackParms := FALSE LargeVars := FALSE *)
(*$ StackChk := FALSE RangeChk := FALSE OverflowChk := FALSE *)
MODULE MUGiff;
FROM Arguments IMPORT GetArg , NumArgs ;
FROM Arts IMPORT Exit , kickVersion ;
FROM Break IMPORT GetBreak ;
IMPORT d : DosD , ed : ExecD , el : ExecL ,
gd : GraphicsD , gl : GraphicsL , id : IntuitionD,
il : IntuitionL, R , rt : ReqTools ;
FROM GraphicsD IMPORT BitMap , BitMapPtr , ChipRevs ,
ChipRevSet , ViewModes , ViewModeSet ;
FROM History IMPORT AUTHOR , REVDATE , REVISION ,
REVTIME ;
FROM IFFLib IMPORT BitMapHeaderPtr, ChunkPtr , CloseIFF ,
comprNone , DecodePic , errorOpen ,
errorNotIff , FindChunk , GetBMHD ,
GetColorTab , GetViewModes , HandlePtr ,
idANIM , idFORM , idILBM ,
IffError , modeRead , ModifyFrame ,
OpenIFF , SaveBitMap ;
FROM IntuitionD IMPORT IDCMPFlags , IDCMPFlagSet , ScreenFlags ,
ScreenFlagSet , WindowFlags , WindowFlagSet ;
FROM String IMPORT Concat , Length ;
FROM SYSTEM IMPORT ADDRESS , ADR , ASSEMBLE ,
CAST , LONGSET , SHIFT ,
TAG ;
FROM Terminal IMPORT WriteString , Format ;
TYPE
str110 = ARRAY [0..110] OF CHAR;
str110Ptr = POINTER TO str110;
colorPtr = POINTER TO colorType;
colorType = ARRAY [0 .. 255] OF CARDINAL;
CONST
couldnt = "Couldn't ";
version = "MUGiff " + REVISION + " (" + REVDATE + ") " +
REVTIME + " © " + AUTHOR;
versionStr = ADR ("$VER: " + version);
HAM = 080H;
agaChips = ChipRevSet{hrAgnus, hrDenise, cr2, cr3, cr4};
(*
** ^- These settings were reported to me by Jeff Hobbs
** (Since I don't have the 3.0 includes I had to read
** gfxBase.chipRevBits0 on a A4000 to get these).
*)
VAR
bigBitMap : gd.BitMap;
bigBitMapPtr : gd.BitMapPtr;
bmhd : BitMapHeaderPtr;
dir : str110Ptr;
dirDum : str110;
i : INTEGER;
iff : HandlePtr;
len : INTEGER;
maxX0,
maxY0 : INTEGER;
myArg : str110;
myFileList : rt.FileListPtr;
ns : id.NewScreen;
nw : id.NewWindow;
screen,
screen2 : id.ScreenPtr;
tBuf : ARRAY [0 .. 2] OF LONGINT;
window : id.WindowPtr;
y0 : INTEGER;
(*$ CopyDyn := FALSE *) (* faster and shorter *)
(*-----------------------------------------------------------------------*)
PROCEDURE MUGerror (error : ARRAY OF CHAR);
(*-----------------------------------------------------------------------*)
BEGIN
WriteString (error);
Exit (d.fail);
END MUGerror;
(*$ EntryExitCode := FALSE *)
(*-----------------------------------------------------------------------*)
PROCEDURE TrueColTab;
(*-----------------------------------------------------------------------*
* The colours for 24bit preview. Thanks to Christian for the idea... *
* But with my method you can preview bigger files (a bit more ugly) *
*-----------------------------------------------------------------------*)
BEGIN
ASSEMBLE(DC.W $000,$111,$222,$333,$444,$555,$666,$777
DC.W $888,$999,$AAA,$BBB,$CCC,$DDD,$EEE,$FFF
END);
END TrueColTab;
(*-----------------------------------------------------------------------*)
PROCEDURE Max (i{R.D0}, j{R.D1} : INTEGER) : INTEGER;
(*-----------------------------------------------------------------------*)
BEGIN
IF (i > j) THEN RETURN i ELSE RETURN j END;
END Max;
(*-----------------------------------------------------------------------*)
PROCEDURE Min (i{R.D0}, j{R.D1} : INTEGER) : INTEGER;
(*-----------------------------------------------------------------------*)
BEGIN
IF (i < j) THEN RETURN i ELSE RETURN j END;
END Min;
(*-----------------------------------------------------------------------*)
PROCEDURE MUGAllocBitMap (w{R.D4}, h{R.D5} : LONGCARD) : BOOLEAN;
(*-----------------------------------------------------------------------*
* This one is based on the RKM: Libraries example. It uses AllocRaster *
* as required by C= *
*-----------------------------------------------------------------------*)
VAR i{R.D2} : SHORTCARD;
allocMaps{R.D3} : BOOLEAN;
BEGIN
i := 0;
allocMaps := TRUE;
gl.InitBitMap (bigBitMap, ns.depth, w, h);
WHILE (i < SHORTCARD (ns.depth)) AND allocMaps DO
bigBitMapPtr^.planes[i] := gl.AllocRaster (w, h);
IF (bigBitMapPtr^.planes[i] = NIL) THEN allocMaps := FALSE; END;
INC (i);
END;
RETURN allocMaps;
END MUGAllocBitMap;
(*-----------------------------------------------------------------------*)
PROCEDURE FileReq (VAR fName{R.A6} : str110Ptr);
(*-----------------------------------------------------------------------*)
(* This is an adapted version of ReqTFileReq by Frank Lömker. Please *
* note that I had to correct ReqTools.def to allow MultiSelect. *
* rt.FileRequest returned BOOLEAN (which is normally quite true) but in *
* MultiSelect mode it is in fact a FileListPtr... *
*-----------------------------------------------------------------------*)
VAR filereq{R.D4} : rt.FileRequesterPtr;
BEGIN
filereq := rt.AllocRequestA (rt.TypeFileReq, NIL);
IF (filereq # NIL) THEN
INCL (filereq^.flags, rt.fReqMultiSelect);
myFileList := rt.FileRequest (filereq, fName, ADR (version), NIL);
IF (myFileList # NIL) THEN
fName^ := CAST (str110Ptr, (filereq^.dir))^;
IF (Length (fName^) > 0) AND (fName^[Length (fName^) - 1] # ':') THEN
Concat(fName^, '/');(* ReqTools doesn't append a '/' so we do it *)
END;
END;
END;
rt.FreeRequest (filereq);
END FileReq;
(*-----------------------------------------------------------------------*)
PROCEDURE SavePic (fName{R.D2} : str110Ptr) : BOOLEAN;
(*-----------------------------------------------------------------------*)
BEGIN
IF (ham IN screen^.viewPort.modes) THEN
RETURN SaveBitMap(fName, bigBitMapPtr,
screen^.viewPort.colorMap^.colorTable, comprNone + HAM)
ELSE
RETURN SaveBitMap(fName, bigBitMapPtr,
screen^.viewPort.colorMap^.colorTable, comprNone )
END;
END SavePic;
(*-----------------------------------------------------------------------*)
PROCEDURE MakeOverscan ();
(*-----------------------------------------------------------------------*
* This is a tricky one. I "borrowed" it from ShowIFF.c. If you know a *
* better way (that is more compatible) feel free to contact me... *
*-----------------------------------------------------------------------*)
VAR x{R.D0}, y{R.D1} : INTEGER;
gfxBasePtr{R.A2} : gd.GfxBasePtr;
BEGIN
gfxBasePtr := ADR (gl);
x := gfxBasePtr^.normalDisplayColumns;
y := gfxBasePtr^.normalDisplayRows;
IF NOT (hires IN screen^.viewPort.modes) THEN x := SHIFT (x, -1); END;
IF (lace IN screen^.viewPort.modes) THEN y := SHIFT (y, 1); END;
x := SHIFT ( (x - screen^.width ), -1);
y := SHIFT ( (y - screen^.height), -1);
IF (y > 0) THEN y := 0; END;
IF ( (gfxBasePtr^.actiView^.dyOffset + y) < 0) THEN
y := 0 - gfxBasePtr^.actiView^.dyOffset;
END;
(* Avoid OverScan HAM fringes *)
IF (ham IN screen^.viewPort.modes) THEN
IF ( (gfxBasePtr^.actiView^.dxOffset + x < 96)) THEN
x := 96 - gfxBasePtr^.actiView^.dxOffset;
END;
END;
screen^.viewPort.dxOffset := x;
screen^.viewPort.dyOffset := y;
il.MakeScreen (screen);
il.RethinkDisplay ();
END MakeOverscan;
(*-----------------------------------------------------------------------*)
PROCEDURE ClosePicture ();
(*-----------------------------------------------------------------------*
* Checks if resources were really allocated and frees them only then *
*-----------------------------------------------------------------------*)
VAR i{R.D2} : SHORTCARD;
BEGIN
IF (window # NIL) THEN
il.CloseWindow (window);
window := NIL;
END;
IF (screen # NIL) THEN
il.CloseScreen (screen);
screen := NIL;
END;
IF (screen2 # NIL) THEN
il.CloseScreen (screen2);
screen2 := NIL;
END;
IF (bigBitMapPtr # NIL) AND (bmhd # NIL) THEN
IF (bigBitMap.depth # 0) THEN
FOR i := 0 TO bigBitMap.depth - 1 DO
IF (bigBitMap.planes[i] # NIL) THEN
gl.FreeRaster (bigBitMap.planes[i],
SHIFT (bigBitMap.bytesPerRow, 3), bigBitMap.rows);
bigBitMap.planes[i] := NIL;
END;
END;
END;
END;
END ClosePicture;
(*-----------------------------------------------------------------------*)
PROCEDURE OpenPicture () : BOOLEAN;
(*-----------------------------------------------------------------------*
* This opens a screen and an apropriate window (for IDCMP-messages). It *
* also calculates the width and height to center the picture. It has a *
* number of safety catches. please note that I had to remove the check *
* for old broken DigiView pix because it reduced the size of colours to *
* 32 (would stop AGA support). *
*-----------------------------------------------------------------------*)
VAR
colorCount{R.D3} : CARDINAL;
colorTab : colorType;
dum {R.D2} : INTEGER;
gfxBasePtr{R.A2} : gd.GfxBasePtr;
BEGIN
gfxBasePtr := ADR (gl);
ClosePicture();
ns.width := gfxBasePtr^.normalDisplayColumns;
ns.height := gfxBasePtr^.normalDisplayRows;
ns.depth := Max (1, bmhd^.nPlanes);
ns.viewModes := GetViewModes (iff);
IF (ns.depth > 8) THEN
ns.depth := 4; (* Hey, this is a 24bit file! Limit it to 4 planes *)
EXCL (ns.viewModes, ham);
ELSIF (ns.depth > 6) AND (gfxBasePtr^.chipRevBits0 # agaChips) THEN
ns.depth := 4; (* Someone wants to view a HAM8 or something on a *)
END; (* pre-AGA machine. We have to limit it to 4 planes...*)
ns.type := id.customScreen + ScreenFlagSet {customBitMap,
screenQuiet, screenBehind};
ns.customBitMap := bigBitMapPtr;
IF (NOT (hires IN ns.viewModes)) THEN
ASSEMBLE( ASR.W ns.width(A4) END);
END;
IF (lace IN ns.viewModes) THEN
ASSEMBLE( ASL.W ns.height(A4) END);
END;
ns.width := Min (bmhd^.w, ns.width );
ns.width := Max (128 , ns.width );
ns.height := Max (128 , ns.height);
IF (hires IN ns.viewModes) THEN dum := 768 ELSE dum := 384 END;
IF ( (CAST (INTEGER, bmhd^.w) > ns.width) AND
(CAST (INTEGER, bmhd^.w) <= dum)) THEN
ns.width := bmhd^.w;
END;
IF (lace IN ns.viewModes) THEN dum := 80 ELSE dum := 40 END;
IF ( CAST (INTEGER, bmhd^.h) > ns.height) AND
(CAST (INTEGER, bmhd^.h) <= (ns.height + dum)) THEN
ns.height := bmhd^.h;
END;
IF MUGAllocBitMap (Max (bmhd^.w,ns.width), Max (bmhd^.h, ns.height)) THEN
screen := il.OpenScreen (ns);
IF (screen # NIL) THEN
nw.screen := screen;
nw.width := ns.width;
nw.height := ns.height;
nw.idcmpFlags := id.IDCMPFlagSet {mouseMove, deltaMove,
mouseButtons, vanillaKey};
nw.flags := id.WindowFlagSet {backDrop, simpleRefresh,
borderless, activate, reportMouse, noCareRefresh, rmbTrap};
nw.type := id.customScreen;
window := il.OpenWindow (nw);
IF (window # NIL) THEN
y0 := SHIFT (CAST (CARDINAL, ns.height) - bmhd^.h, -1);
IF (y0 < 0) THEN y0 := 0; END;
maxX0 := CAST (INTEGER, bmhd^.w) - ns.width;
(*
** ^-- Why this? Because the generated code gives you a overflow
** v-- with (bmhd^.w < ns.width). In C this won't happen :(
*)
maxY0 := CAST (INTEGER, bmhd^.h) - ns.height;
(*
** In 2.0 is a RasInfo scrolling bug. C= said they would fix it in
** newer ROMs so an explicit version check is done
*)
IF (hires IN ns.viewModes) THEN
IF (gfxBasePtr^.libNode.version >= 36) AND
(gfxBasePtr^.libNode.version <= 38) THEN
ASSEMBLE( ASR.W maxX0(A4) END);
(* maxX0 := SHIFT (maxX0, -1);*)
END;
END;
IF (bmhd^.nPlanes = 24) THEN
(*
** Not using a dummy results in a compiler error 7032: Gea:
** adrtoload (Compilerfehler) Very nice ?!
*)
colorTab := CAST (colorPtr, ADR (TrueColTab))^;
colorCount := 16;
ELSE
colorCount := GetColorTab (iff, ADR (colorTab));
IF (colorCount = 0) THEN (* Provide colors for pix w/o CMAP *)
colorCount := 2;
colorTab [0] := 0ECAH;
colorTab [1] := 000H;
END;
END;
gl.LoadRGB4 (ADR (screen^.viewPort), ADR (colorTab), colorCount);
MakeOverscan ();
RETURN TRUE;
END;
END;
END;
ClosePicture ();
RETURN FALSE;
END OpenPicture;
(*-----------------------------------------------------------------------*)
PROCEDURE MUGidcmp (VAR name{R.A2} : str110Ptr) : BOOLEAN;
(*-----------------------------------------------------------------------*
* Checks for mouseMovement, vanillaKey and mouseButtons. The loop is as *
* short as possible for faster reaction on 68000 based systems. *
*-----------------------------------------------------------------------*)
VAR
signals : LONGSET;
msg {R.D3} : id.IntuiMessagePtr;
xOff {R.D6} ,
yOff {R.A3} : POINTER TO INTEGER;
class{R.D5} : IDCMPFlagSet;
moved{R.D4} : BOOLEAN;
mouseX, mouseY : INTEGER;
code : CARDINAL;
BEGIN
moved := FALSE;
xOff := ADR (screen^.viewPort.rasInfo^.rxOffset);
yOff := ADR (screen^.viewPort.rasInfo^.ryOffset);
LOOP
(*
** In 2.0 is a bug in WaitPort. If used without FastMem (like stock
** A500+) it doesn't work! Thanks to Andreas Krebs for information on
** this.
*)
signals := el.Wait (CAST (LONGSET, (
SHIFT (1, window^.userPort^.sigBit))));
(*
** ^-- That's how elegant Modula-2 is compared to C... :^((
*)
msg := el.GetMsg (window^.userPort);
WHILE (msg # NIL) DO
class := msg^.class;
code := msg^.code;
mouseX := msg^.mouseX;
mouseY := msg^.mouseY;
el.ReplyMsg (msg);
IF (vanillaKey IN class) THEN
IF (code = CAST (CARDINAL, 's')) THEN
IF SavePic (name) THEN
WriteString (" written");
RETURN TRUE;
ELSE
Format (couldnt + "write %s ! IffError: %ld",
TAG (tBuf, name, IffError ()));
RETURN FALSE;
END;
ELSE
RETURN TRUE;
END;
END;
IF (mouseButtons IN class) THEN
IF (msg^.code = id.menuDown) THEN RETURN FALSE;
ELSE RETURN TRUE;
END;
END;
IF (mouseMove IN class) THEN moved := TRUE; END;
msg := el.GetMsg (window^.userPort)
END; (* WHILE *)
IF moved THEN
moved := FALSE;
INC (xOff^, mouseX);
INC (yOff^, mouseY);
IF (xOff^ > maxX0) THEN xOff^ := maxX0; END;
IF (xOff^ < 0 ) THEN xOff^ := 0 ; END;
IF (yOff^ > maxY0) THEN yOff^ := maxY0; END;
IF (yOff^ < 0 ) THEN yOff^ := 0 ; END;
il.MakeScreen (screen);
il.RethinkDisplay();
END;
END; (* LOOP *)
END MUGidcmp;
(*-----------------------------------------------------------------------*)
PROCEDURE ShowAnim() : BOOLEAN;
(*-----------------------------------------------------------------------*
* This procedure does some VERY dangerous pointer shifting with *
* undocumented iff.library features. Since the author of iff.library *
* uses this way of programming in his own examples it seems to be legal *
*-----------------------------------------------------------------------*)
VAR
colorCount{R.D4} : CARDINAL;
colorTab : colorType;
scrDummy{R.D2} : id.ScreenPtr;
form {R.A3},
loopform{R.D3} : HandlePtr;
ns : id.NewScreen;
BEGIN
form := CAST (HandlePtr, CAST (LONGCARD, iff) + 12);
(*
** ^- Regarding the definition of IFFL_HANDLE this is completely
** senseless. I've got the suspicion that the library makes an
** internal list of all chunks and that this construct results in the
** next item
*)
bmhd := GetBMHD (form);
IF (bmhd = NIL) THEN
WriteString ("- no bitmap header!\n");
RETURN FALSE;
END;
ns.type := id.customScreen + ScreenFlagSet {screenQuiet,
screenBehind};
ns.width := bmhd^.w;
ns.height := bmhd^.h;
ns.depth := bmhd^.nPlanes;
ns.viewModes := GetViewModes (form);
screen := il.OpenScreen (ns);
screen2 := il.OpenScreen (ns);
IF (screen # NIL) AND (screen2 # NIL) THEN
colorCount := GetColorTab (form, ADR (colorTab));
gl.LoadRGB4 (ADR (screen^.viewPort ), ADR (colorTab), colorCount);
gl.LoadRGB4 (ADR (screen2^.viewPort), ADR (colorTab), colorCount);
IF NOT DecodePic(form, screen^.rastPort.bitMap) THEN
WriteString (couldnt + "decode picture!\n");
RETURN FALSE;
END;
IF DecodePic(form, screen2^.rastPort.bitMap) THEN
il.ScreenToFront (screen2);
gl.WaitTOF();
form := CAST (HandlePtr, FindChunk (form, 0));
(*
** ^- This one "converts" a *IFFL_HANDLE to a *IFFL_Chunk. Not
** recommended! Children: Do not try this at home! ]8^}
*)
IF NOT ModifyFrame(form, screen^.rastPort.bitMap) THEN
WriteString (couldnt + "decode frame 1!\n");
RETURN FALSE;
END;
il.ScreenToFront (screen);
loopform := CAST (HandlePtr, FindChunk (form, 0));
LOOP
form := loopform;
WHILE (CAST (LONGINT, form^.file) = idFORM) DO
(*
** ^- Remember: this is not a IFFL_HANDLE anymore! The first
** entry in a IFFL_Chunk is ckID!
*)
IF (GetBreak() # LONGSET{}) THEN RETURN TRUE; END; (* CtrlC ?? *)
IF ModifyFrame(form, screen2^.rastPort.bitMap) THEN
scrDummy := screen;
screen := screen2;
screen2 := scrDummy;
il.ScreenToFront (screen);
ELSE
WriteString (couldnt + "Decode Frame\n");
RETURN FALSE;
END;
form := CAST (HandlePtr, FindChunk (form, 0));
END;
END;
ELSE
WriteString (couldnt + "decode picture\n");
RETURN FALSE;
END;
ELSE
WriteString (couldnt + "open screens\n");
RETURN FALSE;
END;
WriteString ("- Done");
RETURN TRUE;
END ShowAnim;
(*-----------------------------------------------------------------------*)
PROCEDURE ShowPicture (name : str110Ptr) : BOOLEAN;
(*-----------------------------------------------------------------------*
* This is the main thing. It determines wether it is a picture or an *
* ANIM and calls the apropriate ShowXXXX. *
*-----------------------------------------------------------------------*)
BEGIN
ClosePicture ();
Format ("\nShowing %-40s : ", ADR (name));
IF (iff # NIL) THEN CloseIFF (iff); END;
iff := OpenIFF (name, modeRead);
IF (iff = NIL) THEN
CASE IffError() OF
errorOpen : WriteString (couldnt + "open file!\n");
RETURN TRUE;
| errorNotIff: WriteString ("not IFF!\n" );
RETURN TRUE;
ELSE
WriteString ("not ILBM\n");
RETURN TRUE;
END;
END;
IF (iff^.chunkId = idANIM) THEN
WriteString (" ANIM ");
RETURN ShowAnim();
END;
bmhd := GetBMHD (iff);
IF (bmhd = NIL) THEN
WriteString ("Mangled IFF file\n");
RETURN TRUE;
END;
Format ("%4ld × %4ld × %2ld ", TAG (tBuf, bmhd^.w, bmhd^.h,
bmhd^.nPlanes));
IF OpenPicture () THEN
IF DecodePic (iff, screen^.rastPort.bitMap) THEN
gl.ScrollRaster (ADR (screen^.rastPort), 0, -y0, 0, 0,
SHIFT (bigBitMap.bytesPerRow, 3), bigBitMap.rows);
il.ScreenToFront (screen);
WriteString ("- Done");
RETURN MUGidcmp (name);
ELSE
ClosePicture ();
WriteString ("Decode error!\n");
RETURN TRUE;
END;
ELSE
MUGerror (couldnt + "open screen!\n");
END;
END ShowPicture;
(*-----------------------------------------------------------------------*)
PROCEDURE ChkBreakMsg();
(*-----------------------------------------------------------------------*)
BEGIN
IF NOT ShowPicture (ADR (myArg)) THEN
MUGerror ("\n*** BREAK\n");
END;
END ChkBreakMsg;
(*=========================================================================
M a i n p r o g r a m
=========================================================================*)
BEGIN
dir := ADR (dirDum);
bigBitMapPtr := ADR (bigBitMap);
GetArg (1, myArg, len);
IF (NumArgs() = 0) THEN (* called without args. Is ReqTools there ? *)
IF (rt.reqToolsBase # NIL) THEN
FileReq (dir);
WHILE (myFileList # NIL) DO
myArg := dir^;
Concat(myArg, CAST (str110Ptr, (myFileList^.name))^);
ChkBreakMsg();
ClosePicture();
myFileList := myFileList^.next;
END;
Exit (d.ok);
ELSE
MUGerror (couldnt + "open 'reqtools.library' V38\n");
END;
END;
IF (myArg [0] = "?") THEN (* Hey, someone wants to know about us *)
MUGerror (version + "\nUsage: MUGiff [<file1> .. <fileN>]\n");
END;
FOR i := 1 TO NumArgs() DO
GetArg (i, myArg, len);
ChkBreakMsg();
END;
CLOSE
WriteString ("\nAll done\n");
ClosePicture ();
rt.FreeFileList (myFileList);
IF (iff # NIL) THEN CloseIFF (iff); END;
END MUGiff.